perm filename TRANSF.F4[IRC,LCS] blob sn#646476 filedate 1982-03-07 generic text, type T, neo UTF8
C  READS IN TWO FILES FOR TRANSFORMATION
	IMPLICIT INTEGER (X-Z)
	DIMENSION RN(3)
C  RN WILL HOLD FILE NAMES
	COMMON /A/X1(800),Y1(800),Z1(800),K1
	COMMON /B/X2(800),Y2(800),Z2(800),K2
	COMMON /C/X3(800),Y3(800),Z3(800),K3
	COMMON /D/X4(800),Y4(800),Z4(800),K4
	CALL READX(1)
	CALL READX(2)
C	IF(K1.LT.K2)GO TO 1
C	CALL REVERS
C1	CALL EQUALO
C ASSUMES OUTLINE IS FIRST LONG CONTINUOUS LINE.
C FIRST EQUALIZES OUTLINE, THEN THE REST
C	CALL EQUALZ
	CALL EQUAL
2	CALL PRCNTQ
	CALL OUTPUT
100	END

	SUBROUTINE EQUAL
	COMMON /A/X1(800),Y1(800),Z1(800),K1
	COMMON /D/X4(800),Y4(800),Z4(800),K4
	COMMON /B/X2(800),Y2(800),Z2(800),K2
	COMMON /C/X3(800),Y3(800),Z3(800),K3
	L=1
	K=1
	M=0
4	I=K
	J=L
	CALL SEG(Z1,K,K1,NN1)
	CALL SEG(Z2,L,K2,NN2)
	A=NN1
	B=NN2
	IF(NN1.GT.NN2)GO TO 1
	C=A/B
	D=I
2	DO 3 KK=J,L
	M=M+1
	N=D
	X4(M)=X2(KK)
	Y4(M)=Y2(KK)
C	Z4(M)=Z2(KK)
	X3(M)=X1(N)
	Y3(M)=Y1(N)
	Z3(M)=Z2(KK)
3	D=D+C
6	K=K+1
	L=L+1
	IF(K.LT.K1)GO TO 4
	K3=M
	RETURN
1	C=B/A
	D=J
	DO 5 KK=I,K
	M=M+1
	N=D
	X3(M)=X1(KK)
	Y3(M)=Y1(KK)
	Z3(M)=Z1(KK)
	X4(M)=X2(N)
	Y4(M)=Y2(N)
C	Z4(M)=Z2(KK)
5	D=D+C
	GO TO 6
	END

	SUBROUTINE SEG(Z,K,K1,NN)
	DIMENSION Z(1)
	DO 1 N=K+1,K1
1	IF(Z(N).NE.0)GO TO 2
	N=K1+1
2	NN=N-K
	K=N-1
	END

	SUBROUTINE PRCNTQ
	IMPLICIT INTEGER (X-Z)
	COMMON /A/X1(800),Y1(800),Z1(800),K1
	COMMON /B/X2(800),Y2(800),Z2(800),K2
	COMMON /C/X3(800),Y3(800),Z3(800),K3
	COMMON /D/X4(800),Y4(800),Z4(800),K4
10	FORMAT(' TYPE PERCENT OF TRANSFORMATION (.5=50%)  '$)
11	FORMAT(F)
	TYPE 10
	ACCEPT 11,P
	DO 1 K=1,K3
	A=X4(K)-X3(K)
	A=A*P+.5
	B=Y4(K)-Y3(K)
	B=B*P+.5
	X3(K)=X3(K)+A
1	Y3(K)=Y3(K)+B
	END
	SUBROUTINE READX(N)
C  READS IN TWO FILES FOR TRANSFORMATION
	IMPLICIT INTEGER (X-Z)
	DIMENSION RN(3)
C  RN WILL HOLD FILE NAMES
	COMMON /A/X1(800),Y1(800),Z1(800),K1
	COMMON /B/X2(800),Y2(800),Z2(800),K2
	COMMON /C/X3(800),Y3(800),Z3(800),K3
1	FORMAT(' TYPE FILE NAME  '$)
2	FORMAT(A5)
3	FORMAT(4I)
	WRITE(5,1)
	READ(5,2)RN(N)
	NUM=1
	REWIND NUM
	CALL IFILE(NUM,RN(N))
	GO TO (10,20),N
C  K1 AND K2 WILL HOLD TOTAL OF POINTS.
10	K1=1
100	READ(NUM,3,END=12)K,X1(K1),Y1(K1),Z1(K1)
	K1=K1+1
	GO TO 100
12	K1=K1-1
	RETURN
20	K2=1
200	READ(NUM,3,END=11)K,X2(K2),Y2(K2),Z2(K2)
	K2=K2+1
	GO TO 200
11 	K2=K2-1
	END
 
	SUBROUTINE REVERS
C  REVERSES A AND B DATA. B MUST BE GREATER
	COMMON /A/X1(800),Y1(800),Z1(800),K1
	COMMON /B/X2(800),Y2(800),Z2(800),K2
	COMMON /C/X3(800),Y3(800),Z3(800),K3
	DO 1 K=1,K1
	X3(K)=X1(K)
	Y3(K)=Y1(K)
1	Z3(K)=Z1(K)
	K3=K1
	DO 27 K=1,K2
	X1(K)=X2(K)
	Y1(K)=Y2(K)
27	Z1(K)=Z2(K)
	K1=K2
	DO 3 K=1,K3
	X2(K)=X3(K)
	Y2(K)=Y3(K)
3	Z2(K)=Z3(K)
	K2=K3
	END

	SUBROUTINE FINDO(J,JOUT)
	DIMENSION J(1)
	DO 1 K=2,JOUT
1	IF(J(K).NE.0)GO TO 2
2	JOUT=K-1
C  TOTAL POINTS IN OUTLINE
	END

	SUBROUTINE OUTPUT
	IMPLICIT INTEGER (X-Z)
	COMMON /A/X1(800),Y1(800),Z1(800),K1
	COMMON /B/X2(800),Y2(800),Z2(800),K2
	COMMON /C/X3(800),Y3(800),Z3(800),K3
1	FORMAT(' TYPE OUTPUT FILE NAME  '$)
2	FORMAT(A5)
	TYPE 1
	ACCEPT 2,NAM
	IF(NAM.NE.'DPY')GO TO 20
3	FORMAT(3I4,I2,3X,3I4,I2,3X,3I4,I2,3X,3I4,I2)
	J=K3/4+1
	DO 4 K=1,J
	L=K+J
	M=K+J+J
	N=K+J+J+J
	TYPE 3,K,X3(K),Y3(K),Z3(K),L,X3(L),Y3(L),Z3(L),
	3 M,X3(M),Y3(M),Z3(M),N,X3(N),Y3(N),Z3(N)
4	CONTINUE
	PAUSE
20	CALL OFILE(1,NAM)
	K1=0
	DO 21 K=1,K3
	IF(Z3(K).NE.0)GO TO 28
C LOOK FOR REDUNDANT POINTS
	J=X3(K)
	IF(J.EQ.X3(K+1).AND.J.EQ.X3(K+2))GO TO 21
	J=Y3(K)
	IF(J.EQ.Y3(K+1).AND.J.EQ.Y3(K+2))GO TO 21
28	K1=K1+1
	X1(K1)=X3(K)
	Y1(K1)=Y3(K)
	Z1(K1)=Z3(K)
21	CONTINUE
22	FORMAT(3I4,I2)
	DO 25 K=1,340
	IF(K.LT.320)GO TO 25
	IF(Z1(K).NE.0)GO TO 200
25	WRITE(1,22)K,X1(K),Y1(K),Z1(K)
200	END FILE 1
	NAM=NAM+2
C  BE SURE TO USE 5-LETTER NAME ONLY.
	CALL OFILE(1,NAM)
	M=0
	N=K
	DO 23 K=N,K1
	M=M+1
23	WRITE(1,22)M,X1(K),Y1(K),Z1(K)
	END FILE 1
	END